home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / qwik5x.zip / QWIKDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1988-12-19  |  24KB  |  707 lines
  1. { =========================================================================== }
  2. { QwikDemo.pas - Demo program for QWIK screen utilities.    ver 5.x, 12-20-88 }
  3. { Demo has been programmed best for color cards in 25-line mode.              }
  4. { =========================================================================== }
  5.  
  6. { !! Do not use Ctrl-Break to terminate this program while in the }
  7. { TP integrated environment with integrated debugging on!! }
  8.  
  9. program QwikDemo;
  10.  
  11. { R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }       { TP4 directives }
  12. {$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}  { TP5 directives }
  13. {$M 12000, 0, 0}
  14.  
  15. uses
  16.   Crt,Qwik,Strs;
  17.  
  18. type
  19.   BrdrRec = record                 { For Qbox procedure }
  20.               TL,TH,TR,LV,RV,BL,BH,BR: char;
  21.             end;
  22.  
  23. var
  24.   Row,Rows,Col,Cols,Step,ColMax: byte;
  25.   i,Count,
  26.   Fgrnd,Bgrnd:         word;
  27.   BrdrAttr, WndwAttr:  integer;
  28.   SavedBlock, PopUpBlock: array [1..4000] of byte;
  29.   BlkRow,BlkCol,V:               byte;
  30.   ColL,ColR: array [1..3] of byte;
  31.   Strng,Strng2:          string[75];
  32.   Data: array [1..9 ] of string[40];
  33.   PC:   array [1..14] of string[40];
  34.   Init: array [1..10] of string[40];
  35.   Other:array [1..12] of string[40];
  36.   Crsr: array [1..13] of string[40];
  37.   Eoss: array [1.. 4] of string[40];
  38.   Rnum:                  Real;
  39.   Ch:                    char;
  40.   LastVideoMode:         byte;
  41.  
  42. const
  43.   Wait: word = 400;      { One unit of wait in milliseconds for demo. }
  44.   { These are double lines for Qbox }
  45.   Border: BrdrRec =  (TL:'╔';TH:'═';TR:'╗';
  46.                       LV:'║';       RV:'║';
  47.                       BL:'╚';BH:'═';BR:'╝');
  48.   BWcolors: array[0..3] of byte = (
  49.               Black,        { Black     on Black }
  50.               LightGray,    { LightGray on Black }
  51.               White,        { White     on Black }
  52.               LightGrayBG); { Black     on LightGray }
  53.  
  54. { Since Zenith doesn't have snow on any CGAs, turn off snow checking }
  55. procedure CheckZenith;
  56. var  ZdsRom: array[1..8] of char absolute $F000:$800C;
  57. begin
  58.   if Qsnow and (ZdsRom='ZDS CORP') then
  59.     begin
  60.       Qsnow    := false;
  61.       CardSnow := false;
  62.     end;
  63. end;
  64.  
  65. { Qbox is an application of QWIK screen utilities.  It can make fast
  66.   pop-up menus.  See WNDWxx.ARC for more applications. }
  67. procedure Qbox (Row,Col,Rows,Cols: byte; WndwAttr,BrdrAttr: integer;
  68.                                                       Brdr: BrdrRec);
  69. begin
  70.   if (Rows>=2) and (Cols>=2) then
  71.   begin
  72.     with Brdr do
  73.     begin
  74.       Qwrite    (Row       ,Col                     ,BrdrAttr,TL);
  75.       QfillEos  (                           1,Cols-2,BrdrAttr,TH);
  76.       QwriteEos (                                    BrdrAttr,TR);
  77.       Qfill     (Row+1     ,Col       ,Rows-2,1     ,BrdrAttr,LV);
  78.       Qfill     (Row+1     ,Col+Cols-1,Rows-2,1     ,BrdrAttr,RV);
  79.       Qwrite    (Row+Rows-1,Col                     ,BrdrAttr,BL);
  80.       QfillEos  (                           1,Cols-2,BrdrAttr,BH);
  81.       QwriteEos (                                    BrdrAttr,BR);
  82.       Qfill     (Row+1     ,Col+1     ,Rows-2,Cols-2,WndwAttr,' ')
  83.     end
  84.   end
  85. end;
  86.  
  87. procedure PromptKey;
  88. begin
  89.   Qwrite (25,CRTcols-19,SameAttr,'press any key ...');
  90.   Ch := ReadKey;
  91. end;
  92.  
  93. procedure ClearScreen (Attr: integer);
  94. begin
  95.   Qfill ( 1, 1,CRTrows,CRTcols,Attr,' ');
  96. end;
  97.  
  98. procedure ExplodeBoxes;
  99. var
  100.   TopRow,BottomRow,MaxRows,MaxCols,DeltaCols,LeftCol,RightCol: byte;
  101.   CenterCol:    byte;
  102.   ClockReading: word absolute $0040:$006C; { low memory clock }
  103.   StartTime:    word;
  104.  
  105. {}procedure ScatterBoxes;
  106. {}begin
  107. {}  Rows:= succ(random(MaxRows));
  108. {}  if QVideoMode<=CO40 then              { Keep aspect 1:1 }
  109. {}       Cols:= Rows + Rows shr 2         { 1.2 cols/row }
  110. {}  else Cols:= Rows shl 1 + Rows shr 1;  { 2.4 cols/row }
  111. {}  Col := LeftCol + random (RightCol-LeftCol-Cols+2);
  112. {}  Row := TopRow  + random (BottomRow-TopRow-Rows+2);
  113. {}  if QVideoMode=Mono then
  114. {}  TextAttr:=BWcolors[(random(4))]
  115. {}  else
  116. {}    begin
  117. {}      Fgrnd:= random (16);
  118. {}      Bgrnd:= random (8);
  119. {}      if Bgrnd=Fgrnd then inc(Fgrnd);
  120. {}      TextAttr:=Fgrnd + Bgrnd shl 4;
  121. {}    end;
  122. {}  Qfill (Row,Col,Rows,Cols,TextAttr,#178);
  123. {}end;
  124.  
  125. begin
  126.   CenterCol:=CRTcols shr 1;
  127.   randomize;
  128.   StartTime:=ClockReading;
  129.   for Step:=1 to 12 do
  130.     begin
  131.       { Set boundaries }
  132.       TopRow:=13-Step;
  133.       BottomRow:=13+Step;
  134.       MaxRows:=Step;
  135.       if QVideoMode<=CO40 then                      { Keep aspect 1:1 }
  136.         begin
  137.           MaxCols:= MaxRows + MaxRows shr 2;        { 1.2 cols/row }
  138.           DeltaCols:=(Step*5 div 3);
  139.         end
  140.       else
  141.         begin
  142.           MaxCols:= MaxRows shl 1 + MaxRows shr 1;  { 2.4 cols/row }
  143.           DeltaCols:=(Step*10 div 3);
  144.         end;
  145.       LeftCol  :=succ(CenterCol)-DeltaCols;
  146.       RightCol :=CenterCol+DeltaCols;
  147.       if Step<12 then
  148.         begin
  149.           for Count:=1 to 40 do ScatterBoxes;
  150.         end
  151.       else
  152.         repeat
  153.           ScatterBoxes;
  154.         until ClockReading-StartTime>=60;  { about 60/18.2 seconds }
  155.     end;
  156. end;
  157.  
  158. procedure InitDemo;
  159. begin
  160. { --- Set up data --- }
  161. { If you set a mode, do it first before Qinit! }
  162. { Please!  Test a mode first to see if it is different than what you want; }
  163. { then change if necessary.  Otherwise, the screen jumps. }
  164.  
  165.   CheckBreak := false;
  166.   CheckZenith;
  167.   LastVideoMode := QVideoMode;
  168.   if (QVideoMode<>Mono) and not Have3270 then
  169.     begin
  170.       ClearScreen (LightGray+BlackBG);
  171.       QwriteC (11,1,CRTcols,SameAttr,'(1) 40 column mode');
  172.       QwriteC (12,1,CRTcols,SameAttr,'(2) 80 column mode');
  173.       QwriteC (14,1,CRTcols,SameAttr,'Which mode [1,2]? ');
  174.       GotoEos;
  175.       repeat
  176.         Ch:=ReadKey;
  177.       until ch in ['1','2'];
  178.       V := QVideoMode;
  179.       case ch of
  180.         '1': case V of
  181.                BW80: V:=BW40;
  182.                CO80: V:=CO40;
  183.              end;
  184.         '2': case V of
  185.                BW40: V:=BW80;
  186.                CO40: V:=CO80;
  187.              end;
  188.       end;
  189.       if V<>QVideoMode then
  190.         begin
  191.           TextMode (V+hi(LastMode));
  192.           Qinit;           { << Do Qinit again after change of mode!! }
  193.           CheckZenith;
  194.         end;
  195.     end;
  196.   ModCursor (CursorOff);
  197.   Strng:=   ' Q Screen Utilities ';
  198.   Strng2:=  ' QWIK Screen Utilities  ';
  199.   Data[1]:= '1';
  200.   Data[2]:= '22';
  201.   Data[3]:= '333';
  202.   Data[4]:= Strng;
  203.   Data[5]:= 'Odd  Length';
  204.   Data[6]:= 'Even  Length';
  205.   Data[7]:= '18 characters wide';
  206.   Data[8]:= '19 characters width';
  207.   Data[9]:= 'Margin to Margin width';
  208.   PC[1]:=  'COMPUTERS:           ADAPTERS:';
  209.   PC[2]:=  '------------------   ----------';
  210.   PC[3]:=  'IBM PC               MDA';
  211.   PC[4]:=  'IBM XT               CGA';
  212.   PC[5]:=  'IBM AT               EGA';
  213.   PC[6]:=  'IBM PCjr             MCGA';
  214.   PC[7]:=  'IBM PC Convertible   VGA';
  215.   PC[8]:=  'IBM PS/2 Model 25    8514/A';
  216.   PC[9]:=  'IBM PS/2 Model 30    Hercules:';
  217.   PC[10]:= 'IBM PS/2 Model 50      HGC';
  218.   PC[11]:= 'IBM PS/2 Model 60      HGC Plus';
  219.   PC[12]:= 'IBM PS/2 Model 70      InColor';
  220.   PC[13]:= 'IBM PS/2 Model 80';
  221.   PC[14]:= 'IBM 3270 PC';
  222.   Other[ 1]:='QscrollUp  - Qwik scroll up';
  223.   Other[ 2]:='QscrollDown- Qwik scroll down';
  224.   Other[ 3]:='QscrToVscr - block to virtual screen';
  225.   Other[ 4]:='QVscrToScr - virtual screen to block';
  226.   Other[ 5]:='QreadStr   - reads string from screen';
  227.   Other[ 6]:='QreadChar  - reads char   from screen';
  228.   Other[ 7]:='QreadAttr  - reads attr   from screen';
  229.   Other[ 8]:='QviewPage  - view any video page';
  230.   Other[ 9]:='QwritePage - write to any video page';
  231.   Other[10]:='QwriteA    - for arrays/partial strings';
  232.   Other[11]:='QfillC     - a self-centering Qfill';
  233.   Other[12]:='QattrC     - a self-centering Qattr';
  234.   Crsr[ 1]:='GotoRC        - absolute cursor position';
  235.   Crsr[ 2]:='WhereR        - absolute cursor row';
  236.   Crsr[ 3]:='WhereC        - absolute cursor column';
  237.   Crsr[ 4]:='SetCursor     - sets cursor mode';
  238.   Crsr[ 5]:='GetCursor     - gets cursor mode';
  239.   Crsr[ 6]:='ModCursor     - modifies cursor mode';
  240.   Crsr[ 7]:='CursorInitial   - cu